home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1994 / MacHack 1994.toast / MacHack™94 / Talks & Papers / Timothy Knox / yerk 3.66 / Float source / fltMem < prev    next >
Text File  |  1994-09-14  |  9KB  |  244 lines
  1. \ Memory manager for floating point heap
  2. \  9/01/85  cbd Version 1.0
  3. \  9/24/87  rfl fixed f2dup
  4. \  1/16/94    rfl changed sub.l to suba.l and add.l to adda.l where appropriate
  5.  
  6. \ The floating heap is a region of heap that is divided into 12-byte
  7. \ blocks.  Each block consists of two bytes of status information, along
  8. \ with 10 bytes of data. If the 0 bit of the status field is on, the block
  9. \ is in use. Otherwise, the status field holds the offset of the next
  10. \ free block from the start of the array, and the 0 bit is off because
  11. \ the offset must be even.
  12.  
  13. \ execWord provides an interface from code to a high-level word.
  14. \ If the word completes, it will return to the point in the last
  15. \ high-level word that was executed before the code was invoked.
  16. \ the contents of D0 and D1 are placed on the stack, and the offset
  17. \ of the executed word must be in D7. It can't have named parms.
  18. :CODE execWord
  19.         move.l  a4,-(a7)        ; save old IP on the return stack  
  20.         lea     0(a3,d7.l),a4   ; set up the IP
  21.         move.l  d0,-(a7)        ; push parameters and do a NEXT
  22.         move.l  d1,-(a7)
  23. ;CODE        
  24.  
  25. \ floating-point error handler
  26. : fpErr  SELECT{
  27.     0   IS{ type }END       \ print msg and return to caller 
  28.     1   IS{ cr ." Floating point heap is full." abort }END
  29.     2   IS{ cr ." Not a Float:" . abort }END
  30.     3   IS{ cr ." Uninitialized float argument"  abort }END
  31.     Default{  cr ." Undefined floating point error code" abort
  32.     }SELECT    ;
  33.  
  34. \ Code-based NEW: method for speed
  35. :CODE  fltNew
  36.         move.l  d5,a2           ; get mstack
  37.         movea.l  (A2),a0        ; get obj addr
  38.         adda.l   a3,a0          ; a0 = absolute addr
  39.         clr.l   d7
  40.         move.w  0(a0),d7        ; d7 = offset of first free block
  41.         beq     fullErr
  42.         move.w  0(a0,d7.l),d0     ; d0 = addr of next free block
  43.         move.w  d0,0(a0)        ; Put in free head ptr
  44.         move.w  #1,0(a0,d7.l)     ; mark in use
  45.         add.l   (a2),d7         ; get rel addr of the block
  46.         move.l  d7,-(A7)
  47.         move.l  (a4)+,d6        ; next
  48.         move.l  0(a3,d6.l),d7
  49.         jmp     0(a3,d7.l)
  50. fullErr move.l  #1,d1           ; code for err handler
  51.         move.l  YERK[fpErr],d7
  52.         move.l  YERK[execWord],d6
  53.         jmp     0(a3,d6.l)
  54. ;CODE
  55.  
  56. \ return a float block to the free list - code method
  57. :CODE  fltDisp
  58.         move.l  (A7)+,a1        ; a0 = flt rel addr
  59.         adda.l  a3,a1           ; absolute
  60.         move.l  d5,a2           ; get mstack
  61.         move.l  (a2),a0         ; get receiver
  62.         adda.l  a3,a0           ; absolute receiver addr
  63.         move.w  (a0),d7         ; next free block offset
  64.         move.w  d7,(a1)         ; store link in free block
  65.         suba.l   a0,a1           ; get offs of free block
  66.         move.w  a1,(a0)         ; store in free head ptr        
  67. ;CODE        
  68.  
  69. \ because of assumptions made by code-based methods, this
  70. \ class CANNOT be used to create instance variables.
  71. :CLASS fltHeap  <Super Object  12 <Indexed
  72.  
  73.     Int FreeHead        \ offset of first free block 
  74.  
  75. \ set all blocks to free and link together.
  76.  :M INIT:  limit 1- 0 
  77.      DO  I 1+ (^elem) copyM - I (^elem) w!  LOOP
  78.      0 limit 1- (^elem) w!  0 (^elem) copym - put: freeHead  ;M
  79.  
  80. \ ( -- fPtr ) return a ptr to a new block  
  81.  :M NEW:  fltNew   ;M
  82.  
  83. \  return # of float blocks remaining in float heap
  84.  :M ROOM: { \ offs #free -- #free } get: freeHead  -> offs 0 -> #free
  85.       BEGIN  
  86.         offs 0> offs 1 and not and 
  87.       WHILE   offs copyM + w@ -> offs  1 ++> #free 
  88.       REPEAT  #free ;M
  89.  
  90. \ ( fptr -- )  dispose of block for fptr
  91.  :M DISPOSE:  fltDisp  ;M
  92.  
  93. ;CLASS
  94.  
  95. 100 fltHeap fltMem
  96. init: fltMem
  97.  
  98. \ subroutine returns new float block ptr in d1
  99. \ destroys A0 
  100. :CODE (fltNew)
  101.         move.l  YERK[fltMem],a0
  102.         adda.l   a3,a0
  103.         clr.l   d1
  104.         move.w  (a0),d1             ; d1 = offset of first free block
  105.         beq     fullErr1
  106.         move.w  0(a0,d1.l),(a0)     ; store new free head ptr
  107.         move.w  #1,0(a0,d1.l)       ; mark in use
  108.         suba.l   a3,a0              ; relative again
  109.         add.l   a0,d1               ; get rel addr of the block
  110.         rts
  111. fullerr1  move.l  #1,d1             ; code for err handler
  112.         move.l  YERK[fpErr],d7
  113.         move.l  YERK[execWord],d6
  114.         jmp     0(a3,d6.l)
  115. ;CODE
  116.  
  117. \ dispose of the float in D0 - subroutine. Destroys A0,A1, clears D0
  118. :CODE  (fltDisp)
  119.         move.l  d0,a1
  120.         beq     noFloat
  121.         andi.l  #4278190081,d0  ; $FF000001 range check
  122.         bne     noFloat         ; value is not a float
  123.         adda.l  a3,a1           ; absolute addr of float
  124.         move.l  YERK[fltMem],a0  
  125.         adda.l   a3,a0      
  126.         move.w  (a0),(a1)       ; next free block offset
  127.         suba.l   a0,a1           ; get offs of free block
  128.         move.w  a1,(a0)         ; store in free head ptr 
  129.         rts 
  130. noFloat move.l  #2,d1           ; code for err handler
  131.         move.l  a1,d0           ; value of offending number
  132.         move.l  YERK[fpErr],d7
  133.         move.l  YERK[execWord],d6
  134.         jmp     0(a3,d6.l)
  135.      
  136. ;CODE
  137.  
  138. \ subroutine disposes of floats in d0,d1
  139. \ destroys A0, A1 
  140. :CODE  (fltDisp2)
  141.         move.l  d0,a1
  142.         beq     noFloat1
  143.         andi.l  #4278190081,d0  ; $FF000001 range check
  144.         bne     noFloat1         ; value is not a float
  145.         adda.l  a3,a1           ; absolute
  146.         move.l  YERK[fltMem],a0  ; a0 = float heap ptr
  147.         adda.l  a3,a0           ; absolute 
  148.         move.w  (a0),(a1)       ; next free block offset
  149.         suba.l   a0,a1           ; get offs of free block
  150.         move.w  a1,d0           ; save 
  151.         move.l  d1,a1           ; now do the other one
  152.         beq     noFloat1
  153.         andi.l  #4278190081,d1  ; $FF000001 range check
  154.         bne     noFloat1         ; value is not a float
  155.         adda.l  a3,a1           ; absolute
  156.         move.w  d0,(a1)         ; next free block offset
  157.         suba.l   a0,a1           ; get offs of free block
  158.         move.w  a1,(a0)         ; store in free head ptr 
  159.         rts       
  160. noFloat1 move.l  #2,d1           ; code for err handler
  161.         move.l  a1,d0           ; value of offending number
  162.         move.l  YERK[fpErr],d7
  163.         move.l  YERK[execWord],d6
  164.         jmp     0(a3,d6.l)
  165. ;CODE
  166.  
  167. :CODE fLit
  168.         move.l  YERK[(fltNew)],d7  
  169.         jsr     0(a3,d7.l)        ; get new float in d1
  170.         move.l  (a4)+,2(a3,d1.l)  ; move float data at IP to new block
  171.         move.l  (a4)+,6(a3,d1.l)
  172.         move.w  (a4)+,10(a3,d1.l) 
  173.         move.l  d1,-(a7)        ; push the new float
  174. ;CODE
  175.    
  176.  
  177. :CODE  fDup
  178.         move.l  YERK[(fltNew)],d7  
  179.         jsr     0(a3,d7.l)        ; get new float in d1
  180.         move.l  (A7),d0         ; get float to dup
  181.         lea     2(a3,d0.l),a0
  182.         lea     2(a3,d1.l),a1
  183.         move.l  (a0)+,(a1)+
  184.         move.l  (a0)+,(a1)+
  185.         move.w  (a0)+,(a1)+
  186.         move.l  d1,-(a7)        ; push the new float
  187. ;CODE  
  188.  
  189. \ dup the top two floats on the stack
  190. :CODE  f2Dup
  191.         move.l  (A7),d0         ; get float to dup
  192.         move.l  YERK[(fltNew)],d7  
  193.         jsr     0(a3,d7.l)        ; get new float in d1
  194.         lea     2(a3,d0.l),a0
  195.         lea     2(a3,d1.l),a1
  196.         move.l  (a0)+,(a1)+
  197.         move.l  (a0)+,(a1)+
  198.         move.w  (a0)+,(a1)+
  199.         move.l  d1,d2           ; save the new float
  200.         move.l  4(a7),d0
  201.         move.l  YERK[(fltNew)],d7  
  202.         jsr     0(a3,d7.l)      ; get another float
  203.         lea     2(a3,d0.l),a0
  204.         lea     2(a3,d1.l),a1
  205.         move.l  (a0)+,(a1)+
  206.         move.l  (a0)+,(a1)+
  207.         move.w  (a0)+,(a1)+
  208.         move.l  d1,-(a7)    ; push bottom element
  209.         move.l  d2,-(a7)      
  210. ;CODE  
  211.  
  212. :CODE  fOver
  213.         move.l  4(A7),d0         ; get float to dup
  214.         move.l  YERK[(fltNew)],d7  
  215.         jsr     0(a3,d7.l)        ; get new float in d1
  216.         lea     2(a3,d0.l),a0
  217.         lea     2(a3,d1.l),a1
  218.         move.l  (a0)+,(a1)+
  219.         move.l  (a0)+,(a1)+
  220.         move.w  (a0)+,(a1)+
  221.         move.l  d1,-(a7)        ; push the new float
  222. ;CODE  
  223.  
  224. :CODE fDrop 
  225.         move.l  (A7)+,d0
  226.         move.l  YERK[(fltDisp)],d7  
  227.         jsr     0(a3,d7.l)        ; dispose of float in D0
  228. ;CODE
  229.  
  230. :CODE f2Drop 
  231.         move.l  (A7)+,d0
  232.         move.l  (a7)+,d1
  233.         move.l  YERK[(fltDisp2)],d7  
  234.         jsr     0(a3,d7.l)        ; dispose of float in D0
  235. ;CODE
  236.  
  237.    
  238. ( ops opCode -- )
  239. \ Call FP68K. Floating-point package.
  240. : fp68k     makeint call pack4   ;  
  241.  
  242. \ Call ELEMS68K.  Transcendentals package.
  243. : elems68k  makeint call pack5  ;
  244.